home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / allfil.zip / PIKDIR.PAS < prev    next >
Pascal/Delphi Source File  |  1986-11-02  |  15KB  |  517 lines
  1. {$C-}
  2.  
  3. program dirtest;
  4.   {-develop a popup directory picker}
  5.  
  6. const
  7.   CRTcolumns = 80;
  8.   MaxFiles = 200;
  9.   TxtColor = 15;
  10.   SaveCmdColor = 7;
  11.   SaveBordColor = 112;
  12.   CursorOff = $2000;          {Scan lines to make cursor invisible}
  13.  
  14. type
  15.   WindowRec = record
  16.                 XSize : Byte;
  17.                 YSize : Byte;
  18.                 XPosn : Byte;
  19.                 YPosn : Byte;
  20.                 Contents : array[0..1999] of Integer;
  21.               end;
  22.   WindowPtr = ^WindowRec;
  23.   registers = record
  24.                 case Integer of
  25.                   1 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : Integer);
  26.                   2 : (al, ah, bl, bh, cl, ch, dl, dh : Byte);
  27.               end;
  28.   string80 = string[80];
  29.   pathname = string[64];
  30.   filename = string[12];
  31.   filearray = array[1..MaxFiles] of filename;
  32.  
  33. var
  34.   Screenadr : Integer;
  35.   CursorType : Integer;
  36.   Retracemode : Boolean;
  37.   Reg : registers;
  38.   Fname : filearray;
  39.   Fnum, Totalfiles : Integer;
  40.   W : WindowPtr;
  41.   Mask, Pickname : pathname;
  42.  
  43.   procedure DetermineDisplay;
  44.     { Set Screenadr to $B000 or $B800, depending on which display is in use. }
  45.  
  46.   begin
  47.     {Determine screen type for screen updating procedure}
  48.     Reg.ax := $0F00;
  49.     {BIOS INT 10H call to get screen type}
  50.     Intr($10, Reg);
  51.     Retracemode := (Reg.al <> 7);
  52.     if Retracemode then begin
  53.       {Color card}
  54.       Screenadr := $B800;
  55.       CursorType := $0607;
  56.     end else begin
  57.       Screenadr := $B000;
  58.       CursorType := $0B0C;
  59.     end;
  60.   end;
  61.  
  62.   procedure SetCursor(ScanLines : Integer);
  63.     {-Change the scan lines of the hardware cursor}
  64.  
  65.   begin                       {SetCursor}
  66.     with Reg do begin
  67.       cx := ScanLines;
  68.       ah := 1;
  69.     end;
  70.     Intr($10, Reg);
  71.   end;                        {SetCursor}
  72.  
  73.   procedure MoveToScreen(var Source, Dest; Length : Integer);
  74.     {-Put new text information on the screen, without snow}
  75.  
  76.   begin                       {MoveToScreen}
  77.     if Retracemode then begin
  78.       Length := Length shr 1;
  79.       inline($1E/$55/$BA/$DA/$03/$C5/$B6/Source/$C4/$BE/Dest/$8B/$8E/
  80.         Length/$FC/$AD/$89/$C5/$B4/$09/$EC/$D0/$D8/$72/$FB/$FA/$EC/
  81.         $20/$E0/$74/$FB/$89/$E8/$AB/$FB/$E2/$EA/$5D/$1F);
  82.     end else
  83.       Move(Source, Dest, Length);
  84.   end;                        {MoveToScreen}
  85.  
  86.   procedure MoveFromScreen(var Source, Dest; Length : Integer);
  87.     {-Get text information from the screen, without snow}
  88.  
  89.   begin                       {MoveFromScreen}
  90.     if Retracemode then begin
  91.       Length := Length shr 1;
  92.       inline($1E/$55/$BA/$DA/$03/$C5/$B6/Source/$C4/$BE/Dest/$8B/$8E/
  93.         Length/$FC/$EC/$D0/$D8/$72/$FB/$FA/$EC/$D0/$D8/$73/$FB/$AD/
  94.         $FB/$AB/$E2/$F0/$5D/$1F);
  95.     end else
  96.       Move(Source, Dest, Length);
  97.   end;                        {MoveFromScreen}
  98.  
  99.   procedure FastWrite(St : string80; Row, Col, Attr : Byte);
  100.     {-Write a string to the screen, without snow}
  101.  
  102.   begin                       {FastWrite}
  103.     inline(
  104.       $1E/$8B/$7E/< Row/$4F/$B9/$04/$00/$D3/$E7/$89/$F8/$D1/$E7/$D1/$E7/
  105.       $01/$C7/$8B/$46/< Col/$48/$01/$C7/$D1/$E7/$8D/$76/< St/$8B/$16/
  106.       > Screenadr/$8E/$C2/$A0/> Retracemode/$8C/$D2/$8E/$DA/$8A/
  107.       $0C/$E3/$2B/$46/$8A/$66/< Attr/$FC/$D0/$D8/$73/$1E/$BA/$DA/$03/
  108.       $AC/$89/$C3/$FA/$EC/$A8/$08/$75/$09/$D0/$D8/$72/$F7/$EC/$D0/$D8/
  109.       $73/$FB/$89/$D8/$AB/$FB/$E2/$E8/$E9/$04/$00/$AC/$AB/$E2/$FC/$1F
  110.       );
  111.   end;                        {FastWrite}
  112.  
  113.   function SetupWindow(XLow, YLow, XHigh, YHigh, Attr : Byte) : WindowPtr;
  114.     {-Save existing screen and set up a new text window}
  115.   var
  116.     W : WindowPtr;
  117.     XS, YS : Byte;
  118.     i : Byte;
  119.  
  120.     procedure DrawBox(x1, y1, x2, y2 : Integer; Attr : Byte);
  121.       {-Draw a box}
  122.     var
  123.       i : Byte;
  124.       tb, sid, tlc, trc, blc, brc : Char;
  125.  
  126.     begin                     {DrawBox}
  127.  
  128.       tb := #196;             {Top Border}
  129.       sid := #179;            {Side Border}
  130.       tlc := #218;            {Top Left Corner}
  131.       trc := #191;            {Top Right Corner}
  132.       blc := #192;            {Bottom Left Corner}
  133.       brc := #217;            {Bottom Right Corner}
  134.  
  135.       {Corners}
  136.       FastWrite(tlc, y1, x1, Attr);
  137.       FastWrite(trc, y1, x2, Attr);
  138.       FastWrite(blc, y2, x1, Attr);
  139.       FastWrite(brc, y2, x2, Attr);
  140.  
  141.       {Horizontal}
  142.       for i := Succ(x1) to Pred(x2) do begin
  143.         FastWrite(tb, y1, i, Attr);
  144.         FastWrite(tb, y2, i, Attr);
  145.       end;
  146.  
  147.       {Vertical}
  148.       for i := Succ(y1) to Pred(y2) do begin
  149.         FastWrite(sid, i, x1, Attr);
  150.         FastWrite(sid, i, x2, Attr);
  151.       end;
  152.  
  153.     end;                      {DrawBox}
  154.  
  155.   begin                       {SetupWindow}
  156.  
  157.     XS := Succ(XHigh-XLow);
  158.     YS := Succ(YHigh-YLow);
  159.     {Allocate 2 bytes for each screen position, + 4 for size and position}
  160.     GetMem(W, 2*XS*YS+4);
  161.  
  162.     with W^ do begin
  163.  
  164.       {Store the size}
  165.       XSize := XS;
  166.       YSize := YS;
  167.       XPosn := XLow;
  168.       YPosn := YLow;
  169.  
  170.       {Save the existing contents}
  171.       for i := 0 to YSize-1 do
  172.         MoveFromScreen(Mem[Screenadr:((YPosn+i-1)*CRTcolumns+XPosn-1) shl 1],
  173.         Contents[i*XSize], XSize shl 1);
  174.  
  175.       {Draw box around window}
  176.       DrawBox(XLow, YLow, XHigh, YHigh, Attr);
  177.  
  178.       {Set up Turbo window and clear it}
  179.       Window(Succ(XLow), Succ(YLow), Pred(XHigh), Pred(YHigh));
  180.       ClrScr;
  181.  
  182.       {Turn off cursor}
  183.       SetCursor(CursorOff);
  184.  
  185.     end;
  186.  
  187.     {Return the pointer}
  188.     SetupWindow := W;
  189.  
  190.   end;                        {SetupWindow}
  191.  
  192.   procedure RestoreWindow(var W : WindowPtr);
  193.     {Given a pointer to a WindowRec, restore the contents of the window}
  194.   var
  195.     i : Integer;
  196.  
  197.   begin                       {RestoreWindow}
  198.     with W^ do begin
  199.       {Restore the contents}
  200.       for i := 0 to YSize-1 do
  201.         MoveToScreen(Contents[i*XSize],
  202.         Mem[Screenadr:2*((YPosn+i-1)*CRTcolumns+XPosn-1)], XSize*2);
  203.       {Free the memory}
  204.       FreeMem(W, 2*XSize*YSize+4);
  205.       W := nil;
  206.     end;
  207.     {Reset Turbo window}
  208.     Window(1, 1, 80, 25);
  209.     {Restore cursor}
  210.     SetCursor(CursorType);
  211.   end;                        {RestoreWindow}
  212.  
  213.   procedure GetDirectory(Mask : pathname; var Fname : filearray; var Totalfiles : Integer);
  214.     {-Return an array filled with files matching mask}
  215.   var
  216.     MaskLen : Byte absolute Mask;
  217.     Tmask : pathname;
  218.     DTA : record
  219.             dosuse : array[1..21] of Char;
  220.             dosattr : Byte;
  221.             dostime, dosdate, lsize, hsize : Integer;
  222.             dosname : array[1..13] of Char;
  223.           end;
  224.     DTAseg, DTAofs : Integer;
  225.  
  226.     procedure GetDTA(var Segment, Offset : Integer);
  227.       {-Return address of current DTA}
  228.  
  229.     begin                     {GetDTA}
  230.       Reg.ax := $2F00;
  231.       MsDos(Reg);
  232.       Segment := Reg.es;
  233.       Offset := Reg.bx;
  234.     end;                      {GetDTA}
  235.  
  236.     procedure SetDTA(Segment, Offset : Integer);
  237.       {-Set DTA to new address}
  238.  
  239.     begin                     {SetDTA}
  240.       Reg.ax := $1A00;
  241.       Reg.ds := Segment;
  242.       Reg.dx := Offset;
  243.       MsDos(Reg);
  244.     end;                      {SetDTA}
  245.  
  246.     procedure SortDirectory(var Fname : filearray; Totalfiles : Integer);
  247.       {-Shellsort the directory entries}
  248.     var
  249.       Offset, i, j, k : Integer;
  250.       InOrder : Boolean;
  251.       tmp : filename;
  252.  
  253.     begin                     {SortDirectory}
  254.       Offset := Totalfiles;
  255.       while Offset > 1 do begin
  256.         Offset := Offset shr 1;
  257.         repeat
  258.           InOrder := True;
  259.           k := Totalfiles-Offset;
  260.           for j := 1 to k do begin
  261.             i := j+Offset;
  262.             if Fname[i] < Fname[j] then begin
  263.               {Swap names}
  264.               tmp := Fname[j];
  265.               Fname[j] := Fname[i];
  266.               Fname[i] := tmp;
  267.               InOrder := False;
  268.             end;
  269.           end;
  270.         until InOrder;
  271.       end;
  272.     end;                      {SortDirectory}
  273.  
  274.     function GetFileOK(GetFirst : Boolean; Attr : Byte) : Boolean;
  275.       {-Read entry in DOS directory}
  276.  
  277.       function GetFileName : filename;
  278.         {-return the next non-directory filename from the dta, empty if a dir}
  279.       var
  280.         name : filename;
  281.         i : Byte;
  282.  
  283.       begin                   {GetFileName}
  284.         with DTA do begin
  285.           i := 0;
  286.           while dosname[Succ(i)] <> #0 do
  287.             i := Succ(i);
  288.           Move(dosname, name[1], i);
  289.           name[0] := Chr(i);
  290.         end;
  291.         GetFileName := name;
  292.       end;                    {GetFileName}
  293.  
  294.     begin                     {GetFileOK}
  295.       if GetFirst then begin
  296.         Reg.ah := $4E;
  297.         Reg.ds := Seg(Mask[1]);
  298.         Reg.dx := Ofs(Mask[1]);
  299.         Mask[Succ(MaskLen)] := #0;
  300.       end else
  301.         Reg.ah := $4F;
  302.       Reg.cx := Attr;
  303.       MsDos(Reg);
  304.       if Odd(Reg.flags) or (Totalfiles >= MaxFiles) then
  305.         GetFileOK := False
  306.       else begin
  307.         Totalfiles := Succ(Totalfiles);
  308.         Fname[Totalfiles] := GetFileName;
  309.         GetFileOK := True;
  310.       end;
  311.     end;                      {GetFileOK}
  312.  
  313.   begin                       {GetDirectory}
  314.  
  315.     {Save DTA and point it to our masked version}
  316.     GetDTA(DTAseg, DTAofs);
  317.     SetDTA(Seg(DTA), Ofs(DTA));
  318.  
  319.     {Initialize}
  320.     Totalfiles := 0;
  321.  
  322.     if MaskLen <> 0 then begin
  323.       {See if Mask is a subdirectory}
  324.       Tmask := Mask;
  325.       Mask := Mask+'\*.*';
  326.       if not(GetFileOK(True, 0)) then
  327.         Mask := Tmask;
  328.     end;
  329.  
  330.     {Add default wildcard}
  331.     if (MaskLen = 0) or (Mask[MaskLen] in ['\', ':']) then
  332.       Mask := Mask+'*.*';
  333.  
  334.     {Reinitialize}
  335.     Totalfiles := 0;
  336.  
  337.     {Read the directory}
  338.     if GetFileOK(True, 0) then
  339.       repeat until not GetFileOK(False, 0);
  340.  
  341.     {Restore original DTA}
  342.     SetDTA(DTAseg, DTAofs);
  343.  
  344.     {Sort the directory}
  345.     if Totalfiles > 0 then
  346.       SortDirectory(Fname, Totalfiles);
  347.  
  348.   end;                        {GetDirectory}
  349.  
  350.   function PickDirectory(W : WindowPtr;
  351.                          var Fname : filearray;
  352.                          Totalfiles : Integer;
  353.                          Mask : pathname) : pathname;
  354.     {-Browse and return full pathname of selected file}
  355.   var
  356.     Num : Integer;
  357.     Row, Top, Lines : Byte;
  358.     ch : Char;
  359.     Quitting : Boolean;
  360.  
  361.     function GetCursorCommand : Char;
  362.       {-Return a legal cursor command, WordStar style}
  363.  
  364.     begin                     {GetCursorCommand}
  365.       repeat
  366.         Read(Kbd, ch);
  367.         if (ch = #27) and KeyPressed then begin
  368.           Read(Kbd, ch);
  369.           case ch of
  370.             #72 : ch := ^E;
  371.             #80 : ch := ^X;
  372.           else
  373.             ch := #0;
  374.           end;
  375.         end;
  376.       until ch in [^M, ^[, ^E, ^X];
  377.       GetCursorCommand := ch;
  378.     end;                      {GetCursorCommand}
  379.  
  380.     procedure WriteEntry(Num : Integer; Row, Attr : Byte);
  381.       {-Write one directory entry to the screen}
  382.  
  383.     begin                     {WriteEntry}
  384.       with W^ do
  385.         FastWrite(Fname[Num], YPosn+Row, XPosn+2, Attr);
  386.     end;                      {WriteEntry}
  387.  
  388.     procedure DrawFullPage(Num : Integer);
  389.       {-Draw one full window full of entries, starting at entry num}
  390.     var
  391.       i, n : Integer;
  392.  
  393.     begin                     {DrawFullPage}
  394.       if Lines > Totalfiles then
  395.         n := Totalfiles
  396.       else
  397.         n := Lines;
  398.       for i := 1 to n do
  399.         WriteEntry(Pred(Num+i), i, SaveCmdColor);
  400.     end;                      {DrawFullPage}
  401.  
  402.     function FullPathname(Mask : pathname; Fname : filename) : pathname;
  403.       {-Return a pathname combining mask and fname}
  404.     var
  405.       wild, i : Byte;
  406.       MaskLen : Byte absolute Mask;
  407.  
  408.     begin                     {FullPathname}
  409.       wild := Pos('*', Mask)+Pos('?', Mask);
  410.       if wild <> 0 then begin
  411.         {remove trailing wildcard}
  412.         i := MaskLen;
  413.         while (MaskLen > 0) and not(Mask[MaskLen] in [':', '\']) do
  414.           MaskLen := Pred(MaskLen);
  415.       end;
  416.       if (MaskLen > 0) and not(Mask[MaskLen] in [':', '\']) then
  417.         Mask := Mask+'\';
  418.       FullPathname := Mask+Fname;
  419.     end;                      {FullPathname}
  420.  
  421.   begin                       {PickDirectory}
  422.     with W^ do begin
  423.       if Totalfiles <= 0 then begin
  424.  
  425.         FastWrite(' No files', YPosn+1, XPosn+2, SaveCmdColor);
  426.         FastWrite('Press <Esc>', YPosn+2, XPosn+2, SaveCmdColor);
  427.         FastWrite('to continue', YPosn+3, XPosn+2, SaveCmdColor);
  428.         repeat
  429.           Read(Kbd, ch);
  430.           if (ch = #27) and KeyPressed then
  431.             Read(Kbd, ch);
  432.         until ch = #27;
  433.         PickDirectory := '';
  434.  
  435.       end else begin
  436.  
  437.         Lines := YSize-2;
  438.         Num := 1;
  439.         Row := 1;
  440.         Top := 1;
  441.         DrawFullPage(Num);
  442.         WriteEntry(Num, Row, SaveBordColor);
  443.         Quitting := False;
  444.         repeat
  445.           case GetCursorCommand of
  446.  
  447.             ^M :              {select}
  448.               Quitting := True;
  449.  
  450.             ^[ :              {escape}
  451.               begin
  452.                 Num := 0;
  453.                 Quitting := True;
  454.               end;
  455.  
  456.             ^E :              {scroll up}
  457.               if Num > 1 then begin
  458.                 WriteEntry(Num, Row, SaveCmdColor);
  459.                 Num := Pred(Num);
  460.                 if Row = 1 then begin
  461.                   Top := Num;
  462.                   InsLine;
  463.                 end else
  464.                   Row := Pred(Row);
  465.                 WriteEntry(Num, Row, SaveBordColor);
  466.               end;
  467.  
  468.             ^X :              {scroll down}
  469.               if Num < Totalfiles then begin
  470.                 WriteEntry(Num, Row, SaveCmdColor);
  471.                 Num := Succ(Num);
  472.                 if Row >= Lines then begin
  473.                   GoToXY(1, 1);
  474.                   DelLine;
  475.                   Row := Lines;
  476.                   Top := Succ(Top);
  477.                 end else
  478.                   Row := Succ(Row);
  479.                 WriteEntry(Num, Row, SaveBordColor);
  480.               end;
  481.  
  482.           end;
  483.         until Quitting;
  484.         if Num = 0 then
  485.           PickDirectory := ''
  486.         else
  487.           PickDirectory := FullPathname(Mask, Fname[Num]);
  488.       end;
  489.     end;
  490.   end;                        {PickDirectory}
  491.  
  492. begin
  493.  
  494.   {Set up display addresses}
  495.   DetermineDisplay;
  496.   ClrScr;
  497.  
  498.   {Get a dir mask}
  499.   Write('Enter directory mask: ');
  500.   ReadLn(Mask);
  501.  
  502.   {Setup a new window}
  503.   W := SetupWindow(64, 4, 79, 24, TxtColor);
  504.  
  505.   {Read directory}
  506.   GetDirectory(Mask, Fname, Totalfiles);
  507.  
  508.   {Browse directory and return the selected file name}
  509.   Pickname := PickDirectory(W, Fname, Totalfiles, Mask);
  510.  
  511.   {Restore it}
  512.   RestoreWindow(W);
  513.  
  514.   ClrScr;
  515.   WriteLn('Selected file: ', Pickname);
  516. end.
  517.